perm filename PCROSS.PAS[PAS,SYS]1 blob
sn#452533 filedate 1979-07-05 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00013 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 (*DECLARATIONS*)
C00026 00003 (*INITPROCEDURES*)
C00037 00004 (*CHECKOPTIONS[*) (*SETSWITCH*) (*]*)
C00047 00005 (*PAGE AND LINE CONTROL:*) (*HEADER*) (*NEWPAGE*)
C00049 00006 (*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)
C00057 00007 (*SCANNER:*) (*INSYMBOL[*) (*READBUFFER*) (*RESWORD*) (*FINDNAME*) (*PARENTHESE*) (*DOCOMMENT*) (*]*)
C00072 00008 (*] INSYMBOL*)
C00077 00009 (*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)
C00082 00010 (*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*AND ITS PARTS*) (*]*)
C00093 00011 (*]BLOCK*)
C00100 00012 (*PRINT_XREF_LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)
C00111 00013 (*MAIN PROGRAM*)
C00113 ENDMK
C⊗;
(*DECLARATIONS*)
(*$T-,R50 *)
(*PROGRAM WHICH CREATES A CROSS REFERENCE LISTING WITH SIMULTANEOUS
FORMATTING OF A PASCAL PROGRAM. WRITTEN BY ARMANDO R. RODRIGUEZ.*)
(********************************************************************************
*
* (C) COPYRIGHT 1978, 1979
* BOARD OF TRUSTEES
* LELAND STANFORD JUNIOR UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1978, 1979
* ARMANDO R. RODRIGUEZ
* LOTS COMPUTER FACILITY
* STANFORD UNIVERSITY
* STANFORD, CA. 94305, U. S. A.
*
* (C) COPYRIGHT 1976,
* H.-H. NAGEL
* INSTITUT FUER INFORMATIK
* DER UNIVERSITAET HAMBURG
* SCHLUETERSTRASSE 70
* 2000 HAMBURG-13
* GERMANY
*
(********************************************************************************
(**********************************************************************
*
*
* PROGRAM WHICH CREATES A CROSS REFERENCE LISTING
* AND A NEW, REFORMATTED VERSION OF A PASCAL PROGRAM.
*
* INPUT: PASCAL SOURCE FILE.
* OUTPUT: NEW REFORMATTED SOURCE FILE AND
* CROSS-REFERENCE LISTING.
*
* FROM AN ORIGINAL CROSS-REFERENCE PROCESSOR WRITTEN BY
* MANUEL MALL, UNIVERSITY OF HAMBURG. (1974)
*
* DATE UNKNOWN. LARRY PAULSON (STANFORD).
* + MAKE THE FILES OF TYPE TEXT
* + NOT AS MANY FORCED NEWLINES.
* + THE REPORT ON PROCEDURE CALLS WAS CANCELLED.
*
* MAR-78. ARMANDO R. RODRIGUEZ (STANFORD).
* + A NEW SET OF SWITCH OPTIONS.
* + SOME NEW ERRORS ARE REPORTED.
*
* JUL-78. ARMANDO R. RODRIGUEZ (STANFORD).
* + ACCEPT NON-STANDARD COMMENT CONVENTIONS. STANDARIZE THEM.
* + IMPROVE THE CROSS REFERENCE LISTING.
* + LISTING OF PROC-FUNC CALL NESTING.
* + REPORT THE LINE NUMBERS OF BEGIN AND END OF BODY OF PROCEDURES.
*
* SEE THE PROCEDURE CHECKOPTIONS FOR THE AVAILABLE SWITCHES.
* DEC-78. ARMANDO R. RODRIGUEZ (STANFORD)
* + SPEED UP AND CLEANNING OF THE CODE.
* + FIX SMALL BUGS.
*
* JAN-79. ARMANDO R. RODRIGUEZ (STANFORD)
* + ADDAPT IT TO SAIL CONVENTIONS.
*
* THINGS TO BE FIXED, OR DOCUMENTED:
* + IF THERE ARE TWO PROCS WITH ONE NAME, IT MIXES THEM.
* + IF A PROC NAME IS USED AS A VAR LATER, IT WILL BE SEEN
* AS A PROC FOR CALL-NESTING.
* + MAKE IT SMART ENOUGH TO AVOID CREATING STRUCTURES
* THAT WON'T BE USED, WHEN CROSS IS NOT 15.
*
*
(**********************************************************************)
PROGRAM pcross;
CONST
version ='PCROSS/SAIL FROM 25-JAN-79';
maxline = 51; (*MAXIMUM NUMBER OF LINES PER PAGE, IGNORING HEADER*)
maxcrossch = 120; (*DEFAULT MAXIMUM LINE LENGTH IN CROSSLIST*)
margin = 14;
max_line_count = 7777B; (*LIMIT OF LINES/EDIT-PAGE*)
max_page_count = 77B; (*LIMIT OF EDIT-PAGES*)
(* MAX_LINE_COUNT AND MAX_PAGE_COUNT SHOULD NOT NEED MORE THAN 18 BITS TOTAL*)
ht = 11B; (*ASCII HORIZONTAL TAB*)
ff = 14B; (*ASCII FORM FEED*)
cr = 15B; (*ASCII CARRIAGE RETURN*)
blanks = ' '; (*FOR EDITING PURPOSES*)
dots = ' . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .';
TYPE
pack6 = PACKED ARRAY[1..6] OF char;
pack9 = PACKED ARRAY[1..9] OF char;
errkinds = (begerrinblkstr,missgenduntil,missgthen,missgof,missgexit,
missgrpar,missgquote,missgmain,missgpoint,linetoolong);
lineptrty = ↑line;
listptrty = ↑list;
procstructy = ↑procstruc;
calledty = ↑called;
linenrty = 0..max_line_count;
pagenrty = 0..max_page_count;
symbol = (labelsy,constsy,typesy,varsy,programsy, (*DECSYM*)
functionsy,proceduresy,initprocsy, (*PROSYM*)
endsy,untilsy,elsesy,thensy,exitsy,ofsy,dosy,eobsy, (*ENDSYMBOLS*)
beginsy,casesy,loopsy,repeatsy,ifsy, (*BEGSYM*)
recordsy,forwardsy,gotosy,othersy,intconst,ident,strgconst,externsy,langsy,forsy,whilesy,
rbracket,rparent,semicolon,point,lparent,lbracket,colon,eqlsy,otherssy(*DELIMITER*));
line = PACKED RECORD
(*DESCRIPTION OF THE LINE NUMBER*)
linenr : linenrty; (*LINE NUMBER*)
pagenr : pagenrty; (*PAGE NUMBER*)
contlink : lineptrty; (*NEXT LINE NUMBER RECORD*)
declflag: char; (*'D' IF DECLARATION, 'M' IF MULTIPLE OCCURRENCE,
BLANK OTHERWISE*)
END;
list = PACKED RECORD
(*DESCRIPTION OF IDENTIFIERS*)
name : alfa; (*NAME OF THE IDENTIFIER*)
llink , (*LEFT SUCCESSOR IN TREE*)
rlink : listptrty; (*RIGHT SUCCESSOR IN TREE*)
first , (*POINTER TO FIRST LINE NUMBER RECORD*)
last : lineptrty; (*POINTER TO LAST LINE NUMBER RECORD*)
externflag: char; (*'E' IF EXTERNAL, 'F' IF FORWARD,
'D' IF TWO PROCS WITH THE SAME NAME, BLANK OTHERWISE*)
profunflag : char; (*'P' IF PROCEDURE NAME, 'F' IF FUNCTION, BLANK OTHERWISE*)
procdata: procstructy;
END;
procstruc = PACKED RECORD
(*DESCRIPTION OF THE PROCEDURE NESTING*)
procname : listptrty; (*POINTER TO THE APPROPRIATE IDENTIFIER*)
nextproc : procstructy; (*POINTER TO THE NEXT ELEMENT*)
linenr, (*LINE NUMBER OF THE PROCEDURE DEFINITION*)
begline, (*LINE NUMBER OF THE BEGIN STATEMENT*)
endline: linenrty; (*LINENUMBER OF THE END STATEMENT*)
pagenr , (*PAGE NUMBER OF THE PROCEDURE DEFINITION*)
begpage, (*PAGE NUMBER OF THE BEGIN STATEMENT*)
endpage, (*PAGE NUMBER OF THE END STATEMENT*)
proclevel: pagenrty; (*NESTING DEPTH OF THE PROCEDURE*)
firstcall: calledty; (*LIST OF PROCEDURES CALLED BY THIS ONE*)
printed: boolean; (*TO AVOID LOOPS IN THE CALL-NEST LIST*)
END;
called = PACKED RECORD
nextcall : calledty;
whom : procstructy;
END;
VAR
(* (*INPUT CONTROL*)
(* (***************)
i, (*INDEX VARIABLE*)
bufflen, (*LENGTH OF THE CURRENT LINE IN THE INPUT BUFFER*)
buffmark, (*LENGTH OF THE ALREADY PRINTED PART OF THE BUFFER*)
bufferptr, (*POINTER TO THE NEXT CHARACTER IN THE BUFFER*)
syleng, (*LENGTH OF THE LAST READ IDENTIFIER OR LABEL*)
(* (*NESTING AND MATCHING CONTROL*)
(* (******************************)
bmarknr, (*NUMBER FOR MARKING OF 'BEGIN', 'LOOP' ETC.*)
emarknr, (*NUMBER FOR MARKING OF 'END', 'UNTIL' ETC.*)
level, (*NESTING DEPTH OF THE CURRENT PROCEDURE*)
variant_level, (*NESTING DEPTH OF VARIANTS*)
blocknr, (*COUNTS THE STATEMENTS 'BEGIN', 'CASE', 'LOOP', 'REPEAT', 'IF'*)
errcount, (*COUNTS THE ERRORS ENCOUNTERED*)
(* (*FORMATTING*)
(* (************)
increment, (*LINE NUMBER INCREMENT*)
indentbegin, (*INDENTATION AFTER A BEGIN*)
begexd, (*EXDENTATION FOR BEGIN-END PAIRS*)
feed, (*INDENTATION BY PROCEDURES AND BLOCKS*)
spaces, (*INDENTATION FOR THE CURRENT LINE*)
lastspaces, (*ONE-TIME OVERRIDING VALUE FOR SPACES*)
goodversion, (*KEEPS THE VALUE OF THE VERSION OPTION*)
pagecnt, (*COUNTS THE FILE PAGES*)
pagecnt2, (*COUNTS THE PRINT PAGES PER FILE PAGE*)
maxinc, (*GREATEST ALLOWABLE LINE NUMBER*)
maxch, (*MAXIMUM LINE LENGTH IN CROSSLIST*)
reallincnt, (*COUNTS THE LINES PER PRINT PAGE*)
linecnt : integer; (*COUNTS THE LINES PER FILE PAGE*)
procstrucdata : RECORD
(*NEXT PROCEDURE TO BE PUT IN NESTING LIST*)
exists : boolean;
item : procstruc;
END;
lower : ARRAY [ascii] OF ascii; (*TO MAP UPPER TO LOWER CASE IF DESIRED*)
buffer : ARRAY [-1..302] OF ascii; (*INPUT BUFFER*)
(* BUFFER HAS 2 EXTRA POSITIONS ON THE LEFT AND ONE ON THE RIGHT*)
tabs: ARRAY [1:17] OF ascii; (*A STRING OF TABS FOR FORMATTING*)
linenb : PACKED ARRAY [1..5] OF char; (*SOS-LINE NUMBER*)
date_text,time_text: alfa; (*HEADING DATE AND TIME*)
curprocname, (*NAME OF THE CURRENT PROCEDURE/FUNCTION, FOR THE HEADER*)
prog_name, (*NAME OF CURRENT PROGRAM*)
sy : alfa; (*LAST SYMBOL READ*)
syty : symbol; (*TYPE OF THE LAST SYMBOL READ*)
(* (*SWITCHES*)
(* (**********)
renewing, (*SET IF THE NEWLSOURCE FILE IS BEING WRITTEN*)
crossing, (*SET IF THE CROSSLIST FILE IS BEING WRITEN*)
refing, (*SET IF THE REFERENCES WILL BE PRINTED*)
decnesting, (*SET IF THE PRO-FUNC DECLARATION LISTING WILL BE PRINTED*)
callnesting, (*SET IF THE PRO-FUNC CALL NESTING WILL BE PRINTED*)
doting, (*SET IF DOTED LINES WILL BE PRINTED AT LEFT MARGIN*)
forcing, (*SET IF THEN, ELSE, DO, REPEAT WILL FORCE NEWLINE*)
cleaning, (*SET IF COMMENTS WILL BE STANDARIZED*)
rescase, (*SET IF RESERVED WORDS WILL UPSHIFT*)
nonrcase, (*SET IF NONRESERVED WORDS WILL UPSHIFT*)
comcase, (*SET IF COMMENTS WILL UPSHIFT*)
strcase, (*SET IF STRINGS WILL UPSHIFT*)
thendo, (*SET WHENEVER 'SPACES := SPACES+DOFEED' IS EXECUTED*)
anyversion, (*SET IF GOODVERSION > 9*)
(* (*OTHER CONTROLS*)
(* (****************)
fwddecl, (*SET TRUE BY BLOCK AFTER 'FORWARD', 'EXTERN'*)
oldspaces, (*SET WHEN LASTSPACES SHOULD BE USED*)
commzone, (*SET WHILE SCANNING THE FIRST LINE OF A COMMENT*)
eoline, (*SET AT END ON INPUT LINE*)
gotoinline, (*SET IF A HORRENDOUS GOTO STATEMENT IN THIS LINE*)
declaring, (*SET WHILE PARSING DECLARATIONS*)
firstpage, (*TRUE BEFORE WRITTING ANYTHING*)
programpresent, (*SET AFTER PROGRAM ENCOUNTERED*)
nobody, (*SET IF NO MAIN BODY IS FOUND*)
eob : boolean; (*EOF-FLAG*)
errmsg : PACKED ARRAY[errkinds,1..40] OF char; (*ERROR MESSAGES*)
ch : ascii; (*LAST READ CHARACTER*)
bmarktext, (*CHARACTER FOR MARKING OF 'BEGIN' ETC.*)
emarktext: char; (*CHARACTER FOR MARKING OF 'END' ETC.*)
(* (*SETS*)
(* (******)
delsy : ARRAY [' '..'_'] OF symbol; (*TYPE ARRAY FOR DELIMITER CHARACTERS*)
resnum: ARRAY['A'..'['] OF integer; (*INDEX OF THE FIRST KEYWORD BEGINNING WITH THE INDEXED LETTER*)
reslist : ARRAY [1..46] OF alfa; (*LIST OF THE RESERVED WORDS*)
ressy : ARRAY [1..46] OF symbol; (*TYPE ARRAY OF THE RESERVED WORDS*)
alphanum, (*CHARACTERS FROM 0..9 AND A..Z*)
digits : SET OF char; (*CHARACTERS FROM 0..9*)
relevantsym, (*START SYMBOLS FOR STATEMENTS AND PROCEDURES*)
prosym, (*ALL SYMBOLS WHICH BEGIN A PROCEDURE*)
decsym, (*ALL SYMBOLS WHICH BEGIN DECLARATIONS*)
begsym, (*ALL SYMBOLS WHICH BEGIN COMPOUND STATEMENTS*)
endsym : SET OF symbol; (*ALL SYMBOLS WHICH TERMINATE STATEMENTS OR PROCEDURES*)
(* (*POINTERS AND FILES*)
(* (********************)
listptr, heapmark : listptrty; (*POINTER INTO THE BINARY TREE OF THE IDENTIFIER*)
firstname : ARRAY ['A'..'Z'] OF listptrty; (*POINTER TO THE ROOTS OF THE TREE*)
procstrucf, (*POINTER TO THE FIRST ELEMENT OF THE PROCEDURE CALLS LIST*)
procstrucl : procstructy; (*POINTER TO THE LAST ELEMENT OF THE PROCEDURE CALLS LIST*)
workcall: calledty;
link_name,old_name,
new_name, cross_name: pack9; (*USED TO GET THE PARAMETER FILES*)
old_dev,link_device,
new_dev,cross_dev:pack6;
old_prot,old_ppn,
new_prot,new_ppn,cross_prot,cross_ppn: integer;
programname,oldfileid,newfileid,crossfileid: alfa;
oldsource,newsource,crosslist: text; (*FILES PROCESSED BY THIS PROGRAM*)
(*INITPROCEDURES*)
INITPROCEDURE;
BEGIN (*CONSTANTS*)
eob := false;
increment:=1;
feed:=3;
indentbegin:=0;
begexd:=0;
rescase:=true;
nonrcase:=false;
comcase:=true;
strcase:=true;
renewing:=true;
crossing:=true;
refing:=false;
decnesting:=false;
callnesting:=false;
doting:=true;
nobody := false;
anyversion := false;
goodversion := -1;
new_name:=' ';
cross_name:=' ';
programname:='PCROSS ';
oldfileid:='OLDSOURCE ';
newfileid:='NEWSOURCE ';
crossfileid:='CROSSLIST ';
END (*CONSTANTS*);
INITPROCEDURE;
BEGIN (*RESERVED WORDS*)
resnum['A'] := 1; resnum['B'] := 3; resnum['C'] := 4;
resnum['D'] := 6; resnum['E'] := 9; resnum['F'] := 13;
resnum['G'] := 18; resnum['H'] := 19; resnum['I'] := 19;
resnum['J'] := 22; resnum['K'] := 22; resnum['L'] := 22;
resnum['M'] := 24; resnum['N'] := 25; resnum['O'] := 27;
resnum['P'] := 30; resnum['Q'] := 33; resnum['R'] := 33;
resnum['S'] := 35; resnum['T'] := 36; resnum['U'] := 39;
resnum['V'] := 40; resnum['W'] := 41; resnum['X'] := 43;
resnum['Y'] := 43; resnum['Z'] := 43; resnum['['] := 43;
reslist[ 1] :='AND '; ressy [ 1] := othersy;
reslist[ 2] :='ARRAY '; ressy [ 2] := othersy;
reslist[ 3] :='BEGIN '; ressy [ 3] := beginsy;
reslist[ 4] :='CASE '; ressy [ 4] := casesy;
reslist[ 5] :='CONST '; ressy [ 5] := constsy;
reslist[ 6] :='DO '; ressy [ 6] := dosy;
reslist[ 7] :='DIV '; ressy [ 7] := othersy;
reslist[ 8] :='DOWNTO '; ressy [ 8] := othersy;
reslist[ 9] :='END '; ressy [ 9] := endsy;
reslist[10] :='ELSE '; ressy [10] := elsesy;
reslist[11] :='EXIT '; ressy [11] := exitsy;
reslist[12] :='EXTERN '; ressy [12] := externsy;
reslist[13] :='FOR '; ressy [13] := forsy;
reslist[14] :='FILE '; ressy [14] := othersy;
reslist[15] :='FORWARD '; ressy [15] := forwardsy;
reslist[16] :='FUNCTION '; ressy [16] := functionsy;
reslist[17] :='FORTRAN '; ressy [17] := externsy;
reslist[18] :='GOTO '; ressy [18] := gotosy;
reslist[19] :='IF '; ressy [19] := ifsy;
reslist[20] :='IN '; ressy [20] := othersy;
reslist[21] :='INITPROCED'; ressy [21] := initprocsy;
reslist[22] :='LOOP '; ressy [22] := loopsy;
reslist[23] :='LABEL '; ressy [23] := labelsy;
reslist[24] :='MOD '; ressy [24] := othersy;
reslist[25] :='NOT '; ressy [25] := othersy;
reslist[26] :='NIL '; ressy [26] := othersy;
reslist[27] :='OR '; ressy [27] := othersy;
reslist[28] :='OF '; ressy [28] := ofsy;
reslist[29] :='OTHERS '; ressy [29] := otherssy;
reslist[30] :='PACKED '; ressy [30] := othersy;
reslist[31] :='PROCEDURE '; ressy [31] := proceduresy;
reslist[32] :='PROGRAM '; ressy [32] := programsy;
reslist[33] :='RECORD '; ressy [33] := recordsy;
reslist[34] :='REPEAT '; ressy [34] := repeatsy;
reslist[35] :='SET '; ressy [35] := othersy;
reslist[36] :='THEN '; ressy [36] := thensy;
reslist[37] :='TO '; ressy [37] := othersy;
reslist[38] :='TYPE '; ressy [38] := typesy;
reslist[39] :='UNTIL '; ressy [39] := untilsy;
reslist[40] :='VAR '; ressy [40] := varsy;
reslist[41] :='WHILE '; ressy [41] := whilesy;
reslist[42] :='WITH '; ressy [42] := othersy;
END;
INITPROCEDURE;
BEGIN (*SETS*)
digits := ['0'..'9'];
alphanum := ['0'..'9','A'..'Z'] (*LETTERS OR DIGITS*);
decsym := [labelsy,constsy,typesy,varsy,programsy];
prosym := [functionsy..initprocsy];
endsym := [functionsy..eobsy]; (*PROSYM OR ENDSYMBOLS*)
begsym := [beginsy..ifsy];
relevantsym := [labelsy..initprocsy (*DECSYM OR PROSYM*),beginsy,forwardsy,externsy,eobsy];
END (*SETS*);
PROCEDURE reinitialize;
BEGIN (*REINITIALIZE*)
new(heapmark); (*THE HEAP IS DEALLOCATED AFTER EACH PROGRAM*)
workcall := NIL;
i := 0;
bufflen := 0;
buffmark := 0;
bufferptr := 2;
variant_level := 0;
reallincnt:= maxline;
linecnt :=0;
blocknr := 0;
level := 0;
pagecnt := 1;
pagecnt2 := 0;
errcount := 0;
eoline := true;
gotoinline := false;
firstpage := true;
programpresent := false;
procstrucdata.exists := false;
oldspaces := false;
declaring := false;
commzone := false;
bmarktext := ' ';
emarktext := ' ';
sy := blanks; prog_name := blanks;
date(date_text); time(time_text);
FOR ch := 'A' TO 'Z' DO
firstname [ch] := NIL;
i := 0;
new (firstname['M']);
listptr := firstname ['M'];
WITH firstname ['M']↑ DO
BEGIN
name := 'MAIN PROGM';
llink := NIL;
rlink := NIL;
profunflag := 'M';
new (first);
last := first;
WITH last↑ DO
BEGIN
linenr := 1;
pagenr:=1;
contlink := NIL;
END;
END;
new (procstrucf);
WITH procstrucf↑ DO
BEGIN
procname := firstname ['M'];
nextproc := NIL;
linenr := 1;
pagenr:=1;
proclevel:= 0;
firstcall := NIL;
END;
procstrucl := procstrucf;
curprocname := 'MAIN PROGM';
ch := ' ';
END (*REINITIALIZE*);
PROCEDURE initialize;
BEGIN (*INITIALIZE*)
FOR ch := ' ' TO '_' DO
delsy [ch] := othersy;
delsy ['('] := lparent;
delsy [')'] := rparent;
delsy ['['] := lbracket;
delsy [']'] := rbracket;
delsy [';'] := semicolon;
delsy ['.'] := point;
delsy [':'] := colon;
delsy ['='] := eqlsy;
errmsg[begerrinblkstr] := 'ERROR IN BLOCK STRUCTURE: BEGIN EXPECTED';
errmsg[missgenduntil ] := 'MISSING ''END'' OR ''UNTIL'' NUMBER ';
errmsg[missgthen ] := 'MISSING ''THEN'' FOR ''IF'' NUMBER ';
errmsg[missgof ] := 'MISSING ''OF'' IN ''CASE'' NUMBER ';
errmsg[missgexit ] := 'MISSING ''EXIT'' IN ''LOOP'' NUMBER ';
errmsg[missgrpar ] := 'MISSING RIGHT PARENTHESIS OR BRACKET ';
errmsg[missgquote ] := 'MISSING CLOSING QUOTE ON THIS LINE ';
errmsg[missgmain ] := 'WARNING: THIS FILE HAS NO MAIN BODY ';
errmsg[missgpoint ] := 'MISSING CLOSING POINT AT END OF PROGRAM.';
errmsg[linetoolong ] := 'LINE TOO LONG. I''M GONNA GET CONFUSED. ';
FOR i := -1 TO 201 DO
buffer [i] := ' ';
FOR i := 1 TO 17 DO
tabs [i] := chr (ht);
FOR ch := nul TO '@' DO
lower[ch] := ch;
FOR ch := 'A' TO 'Z' DO
lower[ch] := chr (ord(ch) + 40B);
FOR ch := '[' TO del DO
lower[ch] := ch;
reinitialize;
END (*INITIALIZE*);
(*CHECKOPTIONS[*) (*SETSWITCH*) (*]*)
(*---------------------------------------------------------------------
! CHECKS THE PRESENCE OF SWITCHES WITH THE FILE NAMES.
!
! VALID SWITCHES ARE: BRACKETS INDICATE OPTIONAL.
! <N> STANDS FOR AN INTEGER NUMBER.
! <L> STANDS FOR A LETTER.
!
! SWITCH MEANING DEFAULT.
!
! FILES.
! /[NO]NEW WRITTING OF THE NEWSOURCE FILE ON
! /[NO]CROSS[:<N>] WRITTING OF THE CROSSLIST FILE. ON,15
! <N> IS THE SUM OF:
! 1 SOURCE PROGRAM LISTING
! 2 LISTING OF IDENTIFIERS
! 4 LISTING OF PROC-FUNC
! DECLARATION NESTING.
! 8 LISTING OF PROC-FUNC CALL NESTING.
! /VERSION:<N> BEHAVE AS IF CONDITIONALLY COMPILING %<N>
! COMMENTS. -1
!
! PAGE AND LINE FORMAT
! /CWIDTH:<N> MAXIMUM LINE LENGTH IN CROSSLIST 120
! /INDENT:<N> INDENTATION BETWEEN LEVELS. 4
! /INCREMENT:<N> LINE NUMBER INCREMENT 100
! /[NO]DOTS PUT AS A GUIDE A DOTTED LINE AT THE LEFT
! MARGIN EVERY FIFTH LINE ON
!
! STATEMENT FORMAT
! /BEGIN:[-]<N> IF THE [-] IS NOT THERE, THE CONTENTS OF A
! BEGIN..END BLOCK IS INDENTED N SPACES FURTHER.
! IF IT IS THERE, THE BLOCK WILL NOT BE INDENTED,
! BUT THE BEGIN AND END STATEMENTS WILL BE
! EXDENTED N SPACES. 0
! /[NO]FORCE FORCES NEWLINE IN STANDARD PLACES. (BEFORE AND
! AFTER BEGIN, END, THEN, ELSE, REPEAT, ETC.) OFF
! /[NO]CLEAN CONVERTS THE SYMBOLS FOR BEGIN AND END OF
! COMMENT FROM OLD STANDARDS TO '('-'*' AND
! '*'-')' OFF
!
! UPPER AND LOWER CASE
! NOTE: THE POSSIBLE VALUES FOR <L> ARE:
! U MEANS UPPER CASE
! L MEANS LOWER CASE.
!
! /RES:<L> CASE USED FOR RESERVED WORDS. U
! /NONRES:<L> SAME FOR NON-RESERVED WORDS. L
! /COMM:<L> SAME FOR COMMENTS. U
! /STR:<L> SAME FOR STRINGS. U
! /CASE:<L> RESETS ALL THE DEFAULTS TO <L>. OFF
!
+--------------------------------------------------------------------*)
PROCEDURE checkoptions;
VAR
try: integer;
fromtmp: boolean;
brkchar: char;
PROCEDURE setswitch(opt:alfa;VAR switch:boolean);
VAR
i: integer;
BEGIN (*SETSWITCH*)
getoption(opt,i);
IF i=ord('L') THEN
switch:=false
ELSE
IF i=ord('U') THEN
switch:=true;
END (*SETSWITCH*);
BEGIN (*CHECKOPTIONS*)
askfilename(old_name,old_prot,old_ppn,old_dev,oldfileid,programname,false,fromtmp,brkchar);
startfile(oldsource,old_name,old_prot,old_ppn,old_dev,true,oldfileid,'PAS');
IF NOT option ('NONEW ') THEN
askfilename(new_name,new_prot,new_ppn,new_dev,newfileid,programname,false,fromtmp,brkchar);
IF NOT option ('NOCROSS ') THEN
askfilename(cross_name,cross_prot,cross_ppn,cross_dev,crossfileid,programname,false,fromtmp,brkchar);
IF NOT option ('NONEW ') THEN
BEGIN
IF (new_name = ' ') AND (new_dev = 'DSK ') THEN
BEGIN
getstatus(oldsource, new_name,old_prot,old_ppn,old_dev);
new_name[7]:='N';
new_name[8]:='E';
new_name[9]:='W';
END;
startfile(newsource,new_name,new_prot,new_ppn,new_dev,false,newfileid,' ');
END;
IF NOT option('NOCROSS ') THEN
BEGIN
IF (cross_name = ' ') AND (cross_dev = 'DSK ') THEN
BEGIN
getstatus(oldsource, cross_name,old_prot,old_ppn,old_dev);
cross_name[7]:='C';
cross_name[8]:='R';
cross_name[9]:='L';
END;
startfile(crosslist,cross_name,cross_prot,cross_ppn,cross_dev,false,crossfileid,' ');
END;
renewing:= NOT option('NONEW ');
crossing:= NOT option('NOCROSS ');
IF crossing THEN
BEGIN
getoption('CROSS ',try);
IF try = 0 THEN
try:=15;
callnesting:=try > 7;
decnesting:=(try MOD 8) > 3;
refing:= (try MOD 4) > 1;
crossing:=(try MOD 2) = 1;
END;
IF option ('VERSION ') THEN
BEGIN
getoption ('VERSION ',goodversion);
IF goodversion > 9 THEN
BEGIN
goodversion := -1;
anyversion := true;
END;
END;
IF option('CWIDTH ') THEN
getoption('CWIDTH ',maxch)
ELSE
maxch := maxcrossch;
maxch := maxch - margin;
IF option('INDENT ') THEN
BEGIN
getoption('INDENT ',feed);
IF feed < 0 THEN
feed:=4;
END;
IF option('INCREMENT ') THEN
BEGIN
getoption('INCREMENT ',increment);
IF increment < 0 THEN
increment:= 100;
END;
doting:=NOT option('NODOTS ');
IF option('BEGIN ') THEN
BEGIN
getoption('BEGIN ',indentbegin);
IF indentbegin < 0 THEN
BEGIN
begexd:=-indentbegin;
indentbegin:=0;
END;
END;
forcing:=option('FORCE ');
cleaning := option ('CLEAN ');
IF option('CASE ') THEN
BEGIN
setswitch('CASE ',rescase);
nonrcase:=rescase;
comcase:=rescase;
strcase:=rescase;
END;
setswitch('RES ',rescase);
setswitch('NONRES ',nonrcase);
setswitch('COMM ',comcase);
setswitch('STR ',strcase);
END (*CHECKOPTIONS*);
(*PAGE AND LINE CONTROL:*) (*HEADER*) (*NEWPAGE*)
PROCEDURE header (name: alfa);
(*PRINT TOP OF FORM AND HEADER ON LIST OUTPUT*)
BEGIN (*HEADER*)
pagecnt2 := pagecnt2 + 1;
reallincnt := 0;
IF crossing THEN
BEGIN
IF firstpage THEN
firstpage := false
else
page(crosslist);
write(crosslist,version:26,'[ ':13,prog_name,' ]',' ':13, date_text, ' ', time_text);
writeln (crosslist, 'PAGE ':13, pagecnt:3, '-', pagecnt2:2, name:14);
writeln(crosslist);
END;
END (*HEADER*);
PROCEDURE newpage;
BEGIN (*NEWPAGE*)
pagecnt2 := 0;
pagecnt := pagecnt + 1;
IF renewing THEN
write(newsource, chr(cr), chr(ff));
header (curprocname);
IF eoln (oldsource) THEN
readln(oldsource);
linecnt := 0;
IF prog_name <> blanks THEN
write(tty,pagecnt:3,'..');
break(tty);
END (*NEWPAGE*);
(*BLOCK[*) (*OUTPUT PROCEDURES:*) (*ERROR*) (*WRITELINE[*) (*USEDOTS*) (*]*)
PROCEDURE block;
VAR
curproc : listptrty; (*ZEIGER AUF DIE PROZEDUR IN DEREN ANWEISUNGSTEIL DAS PROGRAMM SICH BEFINDET*)
itisaproc : boolean; (*TRUE WHEN THE WORD PROCEDURE IS FOUND*)
locprocstl: procstructy;
lastprocname: alfa; (*IMPLICIT STACK OF PROCEDURE NAMES FOR THE HEADER*)
PROCEDURE error (errnr : errkinds);
BEGIN (*ERROR*)
errcount := errcount+1;
IF crossing THEN
BEGIN
reallincnt := reallincnt + 1; (*COUNT THE LINE FOR THE ERROR MESSAGE ON CROSSLIST*)
write (crosslist, ' ':17,' *??* ');
CASE errnr OF
begerrinblkstr: write(crosslist, sy, errmsg[begerrinblkstr]);
missgenduntil, missgthen,
missgexit : write(crosslist, errmsg[errnr],emarknr : 4);
missgof, missgrpar,missgmain, missgpoint,linetoolong,
missgquote : write(crosslist, errmsg[errnr]);
END;
writeln(crosslist,' *??*');
END;
writeln(tty);
write (tty, 'ERROR AT ', linecnt*increment: 5, '/', pagecnt:2,': ');
CASE errnr OF
begerrinblkstr: write(tty, sy, errmsg[begerrinblkstr]);
missgenduntil, missgthen,
missgexit : write(tty, errmsg[errnr],emarknr : 4);
missgof, missgrpar,missgmain, missgpoint,linetoolong,
missgquote : write(tty, errmsg[errnr]);
END;
writeln(tty);
break (tty);
END (*ERROR*) ;
PROCEDURE writeline (position (*LETZTES ZU DRUCKENDES ZEICHEN IM PUFFER*): integer);
VAR
i, j, maxchar: integer; (*MARKIERT ERSTES ZU DRUCKENDES ZEICHEN*)
PROCEDURE usedots(lastspaces: integer);
BEGIN (*USEDOTS*)
(*USE EITHER DOTS OR SPACES TO MAKE INDENTATION*)
IF lastspaces > 0 THEN
IF doting AND ((reallincnt MOD 5) = 4) THEN
write(crosslist,dots: lastspaces - 1, ' ')
ELSE
BEGIN
IF lastspaces > 7 THEN
lastspaces := lastspaces + 6;
write(crosslist, tabs: lastspaces DIV 8, ' ': lastspaces MOD 8);
END;
END (*USEDOTS*);
BEGIN (*WRITELINE*)
position := position - 2;
IF position > 0 THEN
BEGIN
i := buffmark + 1; (* 1. DISCARD BLANKS AT BOTH ENDS *)
WHILE (buffer [i] = ' ') AND (i <= position) DO
i := i + 1;
buffmark := position;
WHILE (buffer [position] = ' ') AND (i < position) DO
position := position - 1;
IF i <= position THEN (* 2. IF ANYTHING LEFT, WRITE IT. *)
BEGIN
IF NOT oldspaces THEN
lastspaces := spaces;
linecnt := linecnt + 1;
IF crossing THEN (* 2.1. WRITE THE LINE IN CROSSLIST *)
BEGIN
IF reallincnt >= maxline THEN
header (curprocname);
reallincnt := reallincnt + 1;
IF gotoinline THEN (* 2.1.1. LEFT MARGIN *)
BEGIN
write(crosslist, '***GOTO***');
gotoinline := false;
bmarktext:=' ';
emarktext:=' ';
END
ELSE
BEGIN
IF bmarktext <> ' ' THEN
BEGIN
write (crosslist, bmarktext, bmarknr : 3, ' ');
bmarktext := ' ';
END
ELSE
write(crosslist,' ');
IF emarktext <> ' ' THEN
BEGIN
write (crosslist,emarktext,emarknr : 3,' ');
emarktext := ' ';
END
ELSE
write (crosslist,' ');
END;
write (crosslist, linecnt * increment : 3,' '); (* 2.1.2. LINENUMBER AND INDENTATION *)
usedots(lastspaces);
maxchar:=maxch+i-lastspaces-1;
FOR j := i TO position DO (* 2.1.3. CONTENTS OF THE LINE *)
BEGIN
IF j > maxchar THEN
BEGIN
writeln(crosslist);
IF reallincnt = maxline THEN
header (blanks);
reallincnt:=reallincnt+1;
write(crosslist,tabs:1,' ':6);
IF commzone THEN
usedots(spaces + 1)
ELSE
usedots(lastspaces+feed);
maxchar:=maxch+j-lastspaces-1;
END;
crosslist↑ := buffer[j];
put(crosslist);
END;
writeln(crosslist);
END;
IF renewing THEN (* 2.2. WRITE THE LINE IN NEWSOURCE *)
BEGIN
write (newsource, tabs:lastspaces DIV 8, ' ':lastspaces MOD 8);
FOR j := i TO position DO
BEGIN
newsource↑ := buffer[j];
put(newsource);
END;
writeln(newsource);
END;
WHILE (buffmark < bufflen) AND (buffer[buffmark] = ' ') DO (* 3. RESET POINTERS AND FLAGS *)
buffmark := buffmark + 1;
IF buffmark < bufflen THEN
IF buffer[buffmark - 1] = ' ' THEN
buffmark := buffmark - 1
ELSE
ELSE
IF (linenb = ' ') OR (linecnt >= maxinc) THEN
newpage;
END (* IF I <= POSITION *);
END (* IF POSITION > 0 *);
lastspaces := spaces;
oldspaces := false;
thendo := false;
commzone := false;
END (*WRITELINE*) ;
(*SCANNER:*) (*INSYMBOL[*) (*READBUFFER*) (*RESWORD*) (*FINDNAME*) (*PARENTHESE*) (*DOCOMMENT*) (*]*)
PROCEDURE insymbol ;
LABEL
1, 111;
VAR
incondcomp: boolean;
oldspacesmark, (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KOMMENTAREN*)
i: integer;
PROCEDURE readbuffer;
(*READS A CHARACTER FROM THE INPUT BUFFER*)
PROCEDURE readline;
(*HANDLES LEADING BLANKS AND BLANK LINES, READS NEXT NONBLANK LINE
(WITHOUT LEADING BLANKS) INTO BUFFER*)
VAR
ch : char;
BEGIN (*READLINE*)
(*ENTERED AT THE BEGINNING OF A LINE*)
LOOP
WHILE eoln (oldsource) AND NOT eof (oldsource) DO
BEGIN
(*IS THIS A PAGE MARK?*)
getlinenr (oldsource,linenb);
readln(oldsource);
IF linenb = ' ' THEN
newpage
ELSE (*HANDLE BLANK LINE*)
BEGIN
linecnt := linecnt + 1;
IF crossing THEN
BEGIN
IF reallincnt = maxline THEN
header(curprocname);
reallincnt := reallincnt + 1;
writeln (crosslist, chr(ht),' ',linecnt * increment : 3);
END;
IF renewing THEN
writeln(newsource);
IF maxinc <= linecnt THEN
newpage;
END;
END;
EXIT IF (oldsource↑ <> ' ') OR (eof (oldsource));
get(oldsource);
END;
bufflen := 0;
(*READ IN THE LINE*)
WHILE NOT eoln (oldsource) DO
BEGIN
bufflen := bufflen + 1;
buffer [bufflen] := oldsource↑;
get(oldsource);
END;
IF bufflen > 300 THEN
error(linetoolong);
buffer[bufflen+1] := ' '; (*SO WE CAN ALWAYS BE ONE CHAR AHEAD*)
IF NOT eof (oldsource) THEN
BEGIN
getlinenr (linenb);
readln(oldsource);
END;
bufferptr := 1;
buffmark := 0;
END (*READLINE*) ;
BEGIN (*READBUFFER*)
(*IF READING PAST THE EXTRA BLANK ON THE END, GET A NEW LINE*)
IF eoline THEN
BEGIN
writeline (bufferptr);
ch := ' ';
IF eof (oldsource) THEN
eob := true
ELSE
readline;
END
ELSE
BEGIN
ch := buffer [bufferptr];
bufferptr := bufferptr + 1;
END;
eoline := bufferptr >= bufflen + 2;
END (*READBUFFER*) ;
FUNCTION resword: boolean ;
(*DETERMINES IF THE CURRENT IDENTIFIER IS A RESERVED WORD*)
VAR
i,j: integer;
local: boolean;
BEGIN (*RESWORD*)
local:= false;
i := resnum[sy[1]];
WHILE (i < resnum[succ(sy[1])]) AND NOT local DO
IF reslist[ i ] = sy THEN
BEGIN
local := true;
syty := ressy [i];
IF NOT rescase THEN
FOR j := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[j] := lower[buffer[j]];
END
ELSE
i := i + 1;
resword := local;
END (*RESWORD*) ;
PROCEDURE findname(curproc: listptrty);
VAR
lptr: listptrty; (*ZEIGER AUF DEN VORGAENGER IM BAUM*)
zptr : lineptrty; (*ZEIGER AUF DIE VORLETZTE ZEILENNUMMER IN EINER KETTE*)
found, (*SET AFTER IDENTIFIER IS FOUND*)
right: boolean; (*MERKVARIABLE FUER DIE VERZWEIGUNG IM BAUM*)
indexch : char; (*INDEXVARIABLE FUER DAS FELD DER STARTZEIGER (FIRSTNAME)*)
BEGIN (*FINDNAME*)
indexch := sy [1];
listptr := firstname [indexch];
(*SEARCH IN THE TREE FOR THE IDENTIFIER*)
found := false;
WHILE NOT found AND (listptr <> NIL) DO
BEGIN
lptr:= listptr;
IF sy = listptr↑.name THEN
BEGIN
found := true;
IF (listptr↑.profunflag IN ['P', 'F']) AND (NOT declaring) THEN
IF locprocstl↑.proclevel + 1 >= listptr↑.procdata↑.proclevel THEN
BEGIN
new (workcall);
workcall↑.whom := listptr↑.procdata;
workcall↑.nextcall := NIL;
END;
zptr := listptr↑.last;
IF (zptr↑.linenr <> linecnt+1) OR (zptr↑.pagenr <> pagecnt) THEN
BEGIN
new (listptr↑.last);
WITH listptr↑.last↑ DO
BEGIN
linenr := linecnt + 1;
pagenr := pagecnt;
contlink := NIL;
IF declaring THEN
declflag := 'D'
ELSE
declflag := ' ';
END;
zptr↑.contlink := listptr↑.last;
END
ELSE
zptr↑.declflag := 'M';
END
ELSE
IF sy > listptr↑.name THEN
BEGIN
listptr:= listptr↑.rlink;
right:= true;
END
ELSE
BEGIN
listptr:= listptr↑.llink;
right:= false;
END;
END;
IF NOT found THEN
BEGIN (*UNKNOWN IDENTIFIER*)
new (listptr);
WITH listptr↑ DO
BEGIN
name := sy;
llink := NIL;
rlink := NIL;
profunflag := ' ';
externflag := ' ';
procdata := NIL;
END;
IF firstname [indexch] = NIL THEN
firstname [indexch] := listptr
ELSE
IF right THEN
lptr↑.rlink := listptr
ELSE
lptr↑.llink := listptr;
WITH listptr↑ DO
BEGIN
new (first);
WITH first↑ DO
BEGIN
linenr := linecnt + 1;
pagenr := pagecnt;
contlink := NIL;
IF declaring THEN
declflag := 'D'
ELSE
declflag := ' ';
END;
last := first ;
END;
END;
END (*FINDNAME*) ;
PROCEDURE insertcall;
VAR
lastcall,
thiscall: calledty;
repeated : boolean; (*SET IF SY IS A PROC-NAME AND IS ALREADY IN THE CALL SEQUENCE*)
BEGIN (*INSERTCALL*)
IF locprocstl↑.firstcall = NIL THEN
locprocstl↑.firstcall := workcall
ELSE
BEGIN
thiscall := locprocstl↑.firstcall;
repeated := false;
WHILE (thiscall <> NIL) AND NOT repeated DO
IF thiscall↑.whom↑.procname↑.name = workcall↑.whom↑.procname↑.name THEN
repeated := true
ELSE
BEGIN
lastcall := thiscall;
thiscall := thiscall↑.nextcall;
END;
IF NOT repeated THEN
lastcall↑.nextcall := workcall;
END;
workcall := NIL;
END (*INSERTCALL*);
PROCEDURE parenthese (which: symbol);
(*HANDLES THE FORMATTING OF PARENTHESES, EXCEPT THOSE IN VARIANT PARTS OF RECORDS*)
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON KLAMMERN*)
BEGIN (*PARENTHESE*)
IF variant_level = 0 THEN
BEGIN
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := lastspaces + bufferptr - buffmark - 2;
(*SKIP STUFF UNTIL WE SEEM TO BE OUT OF THE EXPRESSION*)
IF declaring THEN
REPEAT
insymbol;
CASE syty OF
colon: declaring := false;
semicolon: declaring := true;
END;
UNTIL syty IN [externsy..rparent,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy]
ELSE
REPEAT
insymbol
UNTIL syty IN [externsy..rparent,labelsy..typesy,initprocsy..exitsy,dosy..forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = which THEN
insymbol
ELSE
error(missgrpar);
END;
END (*PARENTHESE*) ;
PROCEDURE docomment (dellength: integer; firstch, secondch: char; cleaning: boolean);
VAR
i, lastblank: integer;
PROCEDURE expand (here: integer; firstch, secondch: char);
VAR
i: integer;
BEGIN (*EXPAND*)
bufferptr := here + 2;
bufflen := bufflen + 1;
FOR i := bufflen + 1 DOWNTO here + 2 DO
buffer [i] := buffer [i-1];
buffer [here] := firstch;
buffer [here + 1] := secondch;
END (*EXPAND*);
BEGIN (* DOCOMMENT *)
oldspacesmark := spaces;
IF oldspaces THEN
spaces := lastspaces
ELSE
lastspaces := spaces;
spaces := spaces + bufferptr - buffmark - 1;
oldspaces := true;
commzone := spaces < maxch;
IF NOT commzone THEN
spaces := lastspaces;
IF dellength = 2 THEN
BEGIN
IF cleaning THEN
BEGIN
buffer [bufferptr - 1] := '(';
buffer [bufferptr] := '*';
END;
REPEAT
readbuffer;
IF NOT comcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
UNTIL (ch = secondch) AND (buffer[bufferptr-2] = firstch) OR eob;
IF cleaning THEN
BEGIN
buffer [bufferptr - 2] := '*';
buffer [bufferptr - 1] := ')';
END;
END
ELSE
BEGIN
IF cleaning THEN
expand (bufferptr - 1,'(','*');
REPEAT
readbuffer;
IF NOT comcase THEN
buffer[bufferptr] := lower[buffer[bufferptr]];
UNTIL (ch = firstch) OR eob;
IF cleaning THEN
expand (bufferptr - 1, '*', ')');
END;
REPEAT
readbuffer;
UNTIL ch <> ' ';
spaces := oldspacesmark;
END (*DOCOMMENT*);
PROCEDURE skip_e_directory;
BEGIN (*SKIP_E_DIRECTORY*)
WHILE NOT (oldsource↑ = ';') DO
BEGIN
IF eoln(oldsource) THEN
linecnt := linecnt + 1;
get(oldsource);
END;
get(oldsource);
get(oldsource);
linecnt :=linecnt + 2;
bufferptr := 0;
eoline := true;
END (*SKIP_E_DIRECTORY*);
(*] INSYMBOL*)
BEGIN (*INSYMBOL*)
111:
syleng := 0;
WHILE (ch IN ['_', '(', ' ', '$', '?', '@', '%', '/', '\','"']) AND NOT eob DO
CASE ch OF
'(':
IF (buffer[bufferptr] = '*') THEN
docomment (2,'*',')', false)
ELSE
GOTO 1;
'/':
IF buffer[bufferptr] = '*' THEN
docomment (2,'*','/',cleaning)
ELSE
GOTO 1;
'%':
begin
if not anyversion then
while buffer[bufferptr] in digits do
begin
if ord(buffer[bufferptr]) - ord('0') = goodversion then
incondcomp := true;
readbuffer;
end;
if incondcomp or anyversion then
BEGIN
readbuffer;
readbuffer;
END
ELSE
docomment (1,'\','\',cleaning);
end;
'"':
docomment(1,'"','"',cleaning);
OTHERS:
readbuffer;
END;
CASE ch OF
'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q',
'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y',
'Z':
BEGIN
syleng := 0;
sy := ' ';
REPEAT
syleng := syleng + 1;
IF syleng <= 10 THEN
sy [syleng] := ch;
readbuffer;
UNTIL NOT (ch IN (alphanum + ['_']));
IF firstpage AND (sy = 'COMMENT ') THEN
BEGIN
skip_e_directory;
GOTO 111;
END
ELSE
IF NOT resword THEN
BEGIN
syty := ident ;
findname(curproc);
IF NOT nonrcase THEN
FOR i := bufferptr - syleng - 1 TO bufferptr - 2 DO
buffer[i] := lower[buffer[i]];
END
END;
'0', '1', '2', '3', '4', '5', '6', '7', '8',
'9':
BEGIN
REPEAT
syleng := syleng + 1;
readbuffer;
UNTIL NOT (ch IN digits);
syty := intconst;
IF ch = 'B' THEN
readbuffer
ELSE
BEGIN
IF ch = '.' THEN
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN digits);
syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
END;
IF ch = 'E' THEN
BEGIN
readbuffer;
IF ch IN ['+','-'] THEN
readbuffer;
WHILE ch IN digits DO
readbuffer;
syty := othersy; syleng := 0; (*REALS CAN'T BE LABELS*)
END;
END;
END;
'''':
BEGIN
syty := strgconst;
REPEAT
readbuffer;
UNTIL (ch = '''') OR eob OR eoline;
IF ch <> '''' THEN
error(missgquote);
readbuffer;
END;
'!':
BEGIN
REPEAT
readbuffer
UNTIL NOT (ch IN (digits + ['A'..'F']));
syty := intconst;
END;
' ': syty := eobsy; (*END OF FILE*)
OTHERS:
BEGIN
1:
syty := delsy [ch];
readbuffer;
IF (syty = colon) AND (ch = '=') THEN
BEGIN
workcall := NIL;
syty := othersy;
readbuffer;
END
ELSE
IF syty IN [lparent, lbracket] THEN
IF syty = lparent THEN
parenthese (rparent)
ELSE
parenthese (rbracket);
END
END;
IF workcall <> NIL THEN
insertcall;
END (*INSYMBOL*) ;
(*PARSING OF DECLARATIONS:*) (*RECDEF[*) (*CASEDEF*) (*PARENTHESE*) (*]*)
PROCEDURE recdef;
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON RECORDS*)
PROCEDURE casedef;
VAR
oldspacesmark : integer; (*ALTER ZEICHENVORSCHUB BEI FORMATIERUNG VON VARIANT PARTS*)
PROCEDURE parenthese;
(*HANDLES THE FORMATTING OF PARENTHESES INSIDE VARIANT PARTS*)
VAR
oldspacesmark : integer; (*SAVED VALUE OF 'SPACES'*)
BEGIN (*PARENTHESE*)
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := spaces + bufferptr - 2;
declaring := true;
insymbol;
REPEAT
CASE syty OF
casesy :
casedef;
recordsy :
recdef;
semicolon, lparent:
BEGIN
declaring := true;
insymbol;
END;
eqlsy, colon:
BEGIN
declaring := false;
insymbol;
END;
OTHERS :
insymbol;
END;
(*UNTIL WE APPARENTLY LEAVE THE DECLARATION*)
UNTIL syty IN [strgconst..whilesy,rparent,labelsy..exitsy,dosy..beginsy,
loopsy..forwardsy];
spaces := oldspacesmark;
oldspaces := true;
IF syty = rparent THEN
BEGIN
declaring := true;
insymbol;
END
ELSE
error(missgrpar);
END (*PARENTHESE*) ;
BEGIN (*CASEDEF*)
variant_level := variant_level+1;
oldspacesmark := spaces;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
END;
spaces := bufferptr - buffmark + lastspaces - syleng + 3;
declaring := true;
insymbol;
declaring := false;
REPEAT
IF syty = lparent THEN
parenthese
ELSE
insymbol
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,rparent,dosy..beginsy];
spaces := oldspacesmark;
variant_level := variant_level-1;
END (*CASEDEF*) ;
BEGIN (*RECDEF*)
oldspacesmark := spaces;
oldspaces := true;
lastspaces := spaces;
spaces := bufferptr - buffmark + spaces - syleng - 2 + feed;
declaring := true;
insymbol;
REPEAT
CASE syty OF
casesy : casedef;
recordsy : recdef;
semicolon, lparent:
BEGIN
declaring := true;
insymbol;
END;
eqlsy, colon:
BEGIN
declaring := false;
insymbol;
END;
OTHERS : insymbol
END;
UNTIL syty IN [untilsy..exitsy,labelsy..endsy,dosy..beginsy];
oldspaces := true;
lastspaces := spaces - feed;
spaces := oldspacesmark;
IF syty = endsy THEN
BEGIN
declaring := true;
insymbol;
END
ELSE
error(missgenduntil);
END (*RECDEF*) ;
(*PARSING OF STATEMENTS:*) (*STATEMENT[*) (*AND ITS PARTS*) (*]*)
PROCEDURE statement;
VAR
oldspacesmark, (*SPACES AT ENTRY OF THIS PROCEDURE*)
curblocknr : integer; (*CURRENT BLOCKNUMBER*)
PROCEDURE endedstatseq(endsym: symbol; letter: char);
BEGIN
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
WHILE NOT (syty IN [endsym,eobsy,proceduresy,functionsy]) DO
BEGIN
error(missgenduntil);
IF NOT (syty IN begsym) THEN
insymbol;
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
END;
IF forcing THEN
writeline(bufferptr-syleng);
emarktext := letter;
emarknr := curblocknr;
oldspaces := true;
IF (endsym = endsy) THEN
IF indentbegin = 0 THEN
lastspaces := max(0,spaces-begexd)
ELSE
lastspaces := max(0,spaces-indentbegin)
ELSE
lastspaces := max(0,spaces - feed);
IF syty <> endsym THEN
error(missgenduntil);
END (*ENDEDSTATSEQ*);
PROCEDURE compstat;
BEGIN (*COMPSTAT*)
IF indentbegin = 0 THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-begexd)
END;
END
ELSE
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - indentbegin);
END;
bmarktext := 'B';
insymbol;
IF forcing THEN
writeline(bufferptr-syleng);
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
writeline(bufferptr-syleng);
END;
END (*COMPSTAT*) ;
PROCEDURE casestat;
VAR
oldspacesmark : integer; (*SAVED VALUE OF 'SPACES'*)
BEGIN (*CASESTAT*)
bmarktext := 'C';
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
insymbol;
statement;
IF syty = ofsy THEN
writeline (bufferptr)
ELSE
error (missgof);
LOOP
REPEAT
REPEAT
insymbol;
UNTIL syty IN [colon, functionsy .. eobsy];
IF syty = colon THEN
BEGIN
oldspacesmark := spaces;
lastspaces := spaces;
spaces := bufferptr - buffmark + spaces - 4;
oldspaces := true;
thendo := true;
insymbol;
statement;
IF syty = semicolon THEN
insymbol;
spaces := oldspacesmark;
END;
UNTIL syty IN endsym;
EXIT IF syty IN [endsy,eobsy,proceduresy,functionsy];
error (missgenduntil);
END;
writeline(bufferptr-syleng);
emarktext := 'E';
emarknr := curblocknr;
IF syty = endsy THEN
BEGIN
insymbol ;
writeline(bufferptr-syleng);
END
ELSE
error (missgenduntil);
END (*CASESTAT*) ;
PROCEDURE loopstat;
BEGIN (*LOOPSTAT*)
bmarktext := 'L';
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
insymbol;
writeline(bufferptr-syleng);
statement;
WHILE syty = semicolon DO
BEGIN
insymbol;
statement;
END;
IF syty = exitsy THEN
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := spaces-feed;
emarktext := 'X';
emarknr := curblocknr;
insymbol; insymbol;
END
ELSE
error(missgexit);
endedstatseq(endsy, 'E');
IF syty = endsy THEN
BEGIN
insymbol ;
writeline(bufferptr-syleng);
END;
END (*LOOPSTAT*) ;
PROCEDURE ifstat;
VAR
oldspacesmark: integer;
BEGIN (*IFSTAT*)
oldspacesmark := spaces;
bmarktext := 'I';
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
(*MAKE 'THEN' AND 'ELSE' LINE UP WITH 'IF' UNLESS ON SAME LINE*)
spaces := lastspaces + bufferptr - buffmark + feed - 4;
insymbol;
statement; (*WILL EAT THE EXPRESSION AND STOP ON A KEYWORD*)
IF syty = thensy THEN
BEGIN
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
emarktext := 'T';
emarknr := curblocknr;
IF forcing THEN
writeline(bufferptr)
ELSE
thendo := true;
(*SUPPRESS FURTHER INDENTATION FROM A 'DO'*)
insymbol;
statement;
END
ELSE
error (missgthen);
IF syty = elsesy THEN
BEGIN
writeline(bufferptr-syleng);
emarktext := 'S';
emarknr := curblocknr;
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces-feed);
END;
IF forcing THEN
writeline(bufferptr)
ELSE
thendo := true;
insymbol;
statement;
END;
oldspaces := true; (*PRESERVE INDENTATION OF STATEMENT*)
writeline(bufferptr-syleng);
spaces := oldspacesmark;
END (*IFSTAT*) ;
PROCEDURE labelstat;
BEGIN (*LABELSTAT*)
lastspaces := level * feed;
oldspaces := true;
insymbol;
writeline(bufferptr-syleng);
END (*LABELSTAT*) ;
PROCEDURE repeatstat;
BEGIN
bmarktext := 'R';
IF NOT oldspaces THEN
BEGIN
oldspaces := true;
lastspaces := max (0,spaces - feed);
END;
insymbol;
endedstatseq(untilsy, 'U');
IF syty = untilsy THEN
BEGIN
insymbol;
statement;
writeline(bufferptr-syleng);
END;
END (*REPEATSTAT*) ;
BEGIN (*STATEMENT*)
oldspacesmark := spaces; (*SAVE THE INCOMING VALUE OF SPACES TO BE ABLE TO RESTORE IT*)
IF syty = intconst THEN
BEGIN
insymbol;
IF syty = colon THEN
labelstat;
END;
IF syty IN begsym THEN
BEGIN
blocknr := (blocknr + 1) MOD 1000;
curblocknr := blocknr;
bmarknr := curblocknr;
IF NOT thendo THEN
BEGIN
writeline(bufferptr-syleng);
IF (syty <> beginsy) THEN
spaces := spaces + feed
ELSE
spaces:=spaces + indentbegin;
END;
CASE syty OF
beginsy : compstat;
loopsy : loopstat;
casesy : casestat;
ifsy : ifstat;
repeatsy: repeatstat
END;
END
ELSE
BEGIN
IF forcing THEN
IF syty IN [forsy,whilesy] THEN
writeline(bufferptr-syleng);
IF syty = gotosy THEN
gotoinline:=true;
WHILE NOT (syty IN [semicolon,functionsy..recordsy]) DO
insymbol;
IF syty = dosy THEN
BEGIN
IF NOT thendo THEN
BEGIN
oldspaces := true;
lastspaces := spaces;
spaces := spaces + feed;
IF NOT forcing THEN
thendo := true;
END;
insymbol;
statement;
writeline(bufferptr-syleng);
END;
END;
spaces := oldspacesmark;
END (*STATEMENT*) ;
(*]BLOCK*)
BEGIN (*BLOCK*)
REPEAT
insymbol
UNTIL syty IN relevantsym;
level := level + 1;
curproc := listptr;
spaces := level * feed;
(*HANDLE NESTING LIST*)
locprocstl := procstrucf;
WITH procstrucdata, item, procname↑ DO
IF exists THEN
BEGIN
IF procdata <> NIL THEN
BEGIN
IF externflag = 'F' THEN
procdata := NIL
ELSE
IF externflag = ' ' THEN
externflag := 'D';
locprocstl := procdata;
END;
IF procdata = NIL THEN
BEGIN
IF (syty IN [forwardsy,externsy]) THEN
IF syty = externsy THEN
externflag := 'E'
ELSE
externflag := 'F';
new(procstrucl↑.nextproc);
procstrucl := procstrucl↑.nextproc;
procdata := procstrucl;
procstrucl↑ := item;
locprocstl := procstrucl;
END;
procstrucdata.exists := false
END;
REPEAT
fwddecl := false;
WHILE syty IN decsym DO
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := max(0,spaces-feed);
IF syty = programsy THEN
BEGIN
programpresent := true;
insymbol;
prog_name := sy;
procstrucf↑.procname := listptr;
listptr↑.procdata := procstrucf;
listptr↑.profunflag := 'M';
writeln(tty);
write(tty,version:12,' ',new_name:6,' [ ',prog_name,' ] PAGE');
FOR i := 1 TO pagecnt DO
write (tty, i:3,'..');
break(tty);
declaring := false;
END
ELSE
BEGIN
declaring := true;
IF forcing THEN
writeline(bufferptr);
END;
REPEAT
insymbol;
CASE syty OF
semicolon, lparent : declaring := true;
eqlsy, colon : declaring := false;
recordsy: recdef;
END;
UNTIL syty IN relevantsym;
END;
WHILE syty IN prosym DO
BEGIN
writeline(bufferptr-syleng);
oldspaces := true;
lastspaces := max(0,spaces-feed);
lastprocname := curprocname;
IF syty <> initprocsy THEN
BEGIN
itisaproc := syty = proceduresy;
declaring := true;
insymbol;
curprocname := listptr↑.name;
IF itisaproc THEN
listptr↑.profunflag := 'P'
ELSE
listptr↑.profunflag := 'F';
WITH procstrucdata, item DO
BEGIN
exists := true;
procname := listptr;
nextproc := NIL;
linenr := linecnt+1;
pagenr := pagecnt;
proclevel := level;
printed := false;
firstcall := NIL;
END;
END
ELSE
curprocname := 'INITPROCED';
block;
curprocname := lastprocname;
IF syty = semicolon THEN
insymbol;
END;
(*FORWARD AND EXTERNAL DECLARATIONS MAY COME BEFORE 'VAR', ETC.*)
UNTIL NOT fwddecl;
IF forcing THEN
writeline(bufferptr-syleng);
level := level - 1;
spaces := level * feed;
IF NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy]) THEN
BEGIN
IF (level = 0) AND (syty = point) THEN
nobody := true
ELSE
error (begerrinblkstr);
WHILE NOT (syty IN [beginsy,forwardsy,externsy,eobsy,langsy,point]) DO
insymbol
END;
IF syty = beginsy THEN
BEGIN
declaring := false;
locprocstl↑.begline := linecnt + 1;
locprocstl↑.begpage := pagecnt;
statement;
locprocstl↑.endline := linecnt + 1;
locprocstl↑.endpage := pagecnt;
END
ELSE
IF NOT nobody THEN
BEGIN
fwddecl := true;
insymbol;
END;
IF programpresent AND (level = 0) THEN
BEGIN
IF nobody THEN
BEGIN
error (missgmain);
errcount := errcount - 1;
END;
IF syty <> point THEN
BEGIN
error(missgpoint);
REPEAT (*SKIP TEXT UNTIL END OF FILE OR END OF PROGRAM HIT*)
REPEAT
insymbol
UNTIL (syty = endsy) OR (syty = eobsy);
IF syty = endsy THEN
insymbol;
UNTIL (syty = point) OR (syty = eobsy);
END;
writeline(bufflen+2);
writeln(tty);
writeln (tty,errcount:4,' ERROR(S) DETECTED'); break(tty);
END;
END (*BLOCK*) ;
(*PRINT_XREF_LIST[*) (*CHECKPAGE*) (*WRITEPROCNAME*) (*WRITELINENR*) (*DUMPCALL*) (*]*)
PROCEDURE print_xref_list;
VAR
pred : listptrty;
indexch : char; (*LAUFVARIABLE FUER DAS FELD 'FIRSTNAME' ZUM AUSDRUCKEN*)
listpgnr : boolean; (*TRUE IF THE SOURCE CONTAINS A PAGE MARK*)
itemlen: integer; (*LENGTH OF A PRINTED LINENUMBER, 6 OR 9*)
thiscall : calledty;
oldcrossing: boolean;
PROCEDURE checkpage(heading: boolean);
BEGIN
IF reallincnt = maxline THEN
BEGIN
IF heading THEN
header (listptr↑.name)
ELSE
header (blanks);
END;
reallincnt:=reallincnt+1;
END(*CHECKPAGE*);
PROCEDURE writeprocname (procstrucl: procstructy; depth: integer; mark: char; numbering: boolean);
BEGIN (*WRITEPROCNAME*)
writeln(crosslist);
checkpage(false);
WITH procstrucl↑, procname↑ DO
BEGIN
IF numbering THEN
write (crosslist, linecnt * increment:5, ' ');
IF depth > 2 THEN
write (crosslist, '. ',dots:depth-2)
ELSE
write (crosslist, '.':depth);
write (crosslist, name : 10, ' (', profunflag, ')',
mark:2, externflag:2, chr(ht), linenr * increment : 3);
IF listpgnr OR (pagenr > 1) THEN
write(crosslist, '/',pagenr : 2);
IF (mark = ' ') AND NOT (externflag IN ['E', 'F']) THEN
BEGIN
write (crosslist, begline * increment: 5);
IF listpgnr THEN
write (crosslist, '/', begpage: 2);
write (crosslist, endline * increment: 5);
IF listpgnr THEN
write (crosslist, '/', endpage:2);
END
ELSE
IF externflag = 'F' THEN
externflag := ' ';
END;
END (*WRITEPROCNAME*);
PROCEDURE writelinenr (spaces : integer);
VAR
link : lineptrty; (*ZEIGER ZUM DURCHHANGELN DURCH DIE VERKETTUNG DER ZEILENNUMMERN*)
maxcnt, (*MAXIMUM ALLOWABLE VALUE OF COUNT*)
count : integer; (*ZAEHLT DIE GEDRUCKTEN ZEILENNUMMERN PRO ZEILE*)
BEGIN (*WRITELINENR*)
count := 0;
maxcnt := (maxch+16 - spaces) DIV itemlen; (*ITEMS ARE ITEMLEN CHARS EACH*)
link := listptr↑.first;
REPEAT
IF count = maxcnt THEN
BEGIN
writeln(crosslist);
checkpage(true);
write (crosslist, ' ' : spaces);
count := 0;
END;
count := count + 1;
WITH link↑ DO
BEGIN
write (crosslist, linenr * increment : 4);
IF listpgnr THEN
write(crosslist, '/',pagenr : 2);
write (crosslist,declflag);
link := contlink;
END;
UNTIL link = NIL;
END (*WRITELINENR*) ;
PROCEDURE dumpcall (thisproc: procstructy; depth: integer);
VAR
thiscall: calledty;
BEGIN (*DUMPCALL*)
linecnt := linecnt + 1;
WITH thisproc↑ DO
IF printed THEN
writeprocname (thisproc, depth,'*', true)
ELSE
BEGIN
writeprocname (thisproc, depth, ' ', true);
printed := true;
linenr := linecnt;
pagenr := pagecnt;
thiscall := firstcall;
WHILE thiscall <> NIL DO
BEGIN
dumpcall (thiscall↑.whom, depth + 4);
thiscall := thiscall↑.nextcall;
END;
END;
END (*DUMPCALL*);
BEGIN (*PRINT_XREF_LIST*)
oldcrossing := crossing;
crossing := true;
listpgnr := pagecnt > 1;
IF listpgnr THEN
itemlen := 9
ELSE
itemlen := 6;
WITH firstname ['M']↑ DO (*DELETE 'MAIN'*)
IF rlink = NIL THEN
firstname ['M'] := llink
ELSE
BEGIN
listptr := rlink;
WHILE listptr↑.llink <> NIL DO
listptr := listptr↑.llink;
listptr↑.llink := llink;
firstname ['M'] := rlink;
END;
indexch := 'A';
WHILE (indexch < 'Z') AND (firstname [indexch] = NIL) DO
indexch := succ (indexch);
IF firstname [indexch] <> NIL THEN
BEGIN
IF refing THEN
BEGIN
pagecnt := pagecnt + 1;
pagecnt2 := 0;
IF reallincnt < maxline THEN
page(crosslist);
header (blanks);
writeln (crosslist, 'CROSS REFERENCE LISTING OF IDENTIFIERS');
writeln (crosslist, '**************************************');
reallincnt:= reallincnt + 3;
FOR indexch := indexch TO 'Z' DO
WHILE firstname [indexch] <> NIL DO
BEGIN
listptr := firstname [indexch];
WHILE listptr↑.llink <> NIL DO
BEGIN
pred := listptr;
listptr := listptr↑.llink;
END;
IF listptr = firstname [indexch] THEN
firstname [indexch] := listptr↑.rlink
ELSE
pred↑.llink := listptr↑.rlink;
writeln(crosslist);
checkpage(true);
write (crosslist, listptr↑.profunflag, listptr↑.name : 11);
writelinenr (12);
END;
END;
IF procstrucl <> procstrucf THEN
BEGIN
IF decnesting THEN
BEGIN
pagecnt := pagecnt + 1;
pagecnt2 := 0;
writeln (crosslist);
IF reallincnt < maxline THEN
page(crosslist);
header ('*DECLARAT*');
writeln (crosslist, 'NESTING OF PROCEDURE-FUNCTION DECLARATION');
writeln (crosslist, '*****************************************');
writeln (crosslist, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');
reallincnt:= reallincnt + 4;
procstrucl := procstrucf;
REPEAT
writeprocname (procstrucl, procstrucl↑.proclevel * 4, ' ', false);
procstrucl := procstrucl↑.nextproc;
UNTIL procstrucl = NIL;
END;
IF callnesting THEN
BEGIN
pagecnt := pagecnt + 1;
pagecnt2 := 0;
writeln (crosslist);
IF reallincnt < maxline THEN
page(crosslist);
header ('* CALLS * ');
writeln (crosslist, 'NESTING OF PROCEDURE-FUNCTION CALLS');
writeln (crosslist, '***********************************');
writeln (crosslist, 'NAME, P/F, HEADERLINE, BEGINLINE, ENDLINE');
reallincnt := reallincnt + 4;
linecnt := 0;
procstrucl := procstrucf;
WHILE procstrucl <> NIL DO
BEGIN
IF NOT procstrucl↑.printed THEN
dumpcall (procstrucl, 0);
procstrucl := procstrucl↑.nextproc;
END;
END;
END;
END;
crossing := oldcrossing;
END (*PRINT_XREF_LIST*) ;
(*MAIN PROGRAM*)
BEGIN
settime;
checkoptions;
getstatus(oldsource,new_name,new_prot,new_ppn,new_dev);
initialize;
(*FIND MAX POSSIBLE LINE NUMBER WITH THIS INCREMENT*)
maxinc := (1000 DIV increment);
LOOP
block;
EXIT IF NOT programpresent OR (syty = eobsy);
IF refing OR decnesting OR callnesting THEN
print_xref_list;
dispose(heapmark); (*RELEASE THE ENTIRE HEAP*)
reinitialize;
END;
timereport(ttyoutput, ' ');
writeln(tty,'REMEMBER TO USE THE /NOHEAD SWITCH WHEN SPOOLING');
getnextcall (link_name, link_device);
IF link_name <> ' ' THEN
call (link_name, link_device);
END (*PCROSS*).